home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / command-interface / mcl-support.scm < prev    next >
Encoding:
Text File  |  1994-09-28  |  27.9 KB  |  839 lines  |  [TEXT/CCL2]
  1. ;;; mcl-support.scm -- support functions for MCL-based user interface
  2. ;;;
  3. ;;; author :  Sandra Loosemore
  4. ;;; date   :  01 Sep 1993
  5. ;;;
  6. ;;;
  7. ;;; Note:  This file contains a lot of MCL-specific code.  
  8.  
  9.  
  10.  
  11. ;;;=========================================================================
  12. ;;; Setup
  13. ;;;=========================================================================
  14.  
  15.  
  16. ;;; The input hook just makes an appropriate tweak to the message area,
  17. ;;; and then reads from standard input.
  18.  
  19. (define *mac-auto-switch-input* '#t)
  20.  
  21. (define (mac-input-hook)
  22.   (mac-status "input")
  23.   (when *mac-auto-switch-input*
  24.     (ccl:window-select (ccl::current-listener))
  25.     (ccl:ed-beep))
  26.   (let ((result  (read-line)))
  27.     (mac-status "busy")
  28.     result))
  29.  
  30. ;;; Debugger hooks tweak the message area and switch to the MCL menubar
  31. ;;; for debugging.  This makes things like the restarts menu available.
  32.  
  33. (define *mac-haskell-menubar* '#f)   ; initialized later
  34.  
  35. (define (mac-enter-debugger-hook)
  36.   (ccl:set-menubar ccl:*default-menubar*)
  37.   (mac-status "debug"))
  38.  
  39. (define (mac-exit-debugger-hook)
  40.   (ccl:set-menubar *mac-haskell-menubar*)
  41.   (mac-status "busy"))
  42.  
  43.  
  44. ;;; Here's the thing to process commands.  It's basically a polling loop.
  45. ;;; ccl:get-next-queued-form reads things that have been queued with
  46. ;;; ccl:eval-enqueue (menu items).
  47.  
  48. (define (mac-command-hook)
  49.   (mac-status "ready")
  50.   (vanilla-prompt)
  51.   (block got-command
  52.     (do () ('#f)
  53.       ;; This lets MCL catch up on other events.
  54.       (dynamic-let ((ccl:*idle*    '#t))
  55.         (ccl:event-dispatch))
  56.       (let ((form  (ccl:get-next-queued-form)))
  57.         (cond (form
  58.                ;; Execute stuff from queue before reading new input.
  59.                (mac-status "busy")
  60.                (terpri)  ;; Newline after prompt
  61.                (return-from got-command (eval form)))
  62.               ((cl:listen)
  63.                ;; There is input available now in the listener window.  
  64.            ;; Read it and do the normal command processing.
  65.                (mac-status "busy")
  66.                (return-from got-command (vanilla-read-and-execute-command)))
  67.               (else
  68.                ;; Nothing to do yet, poll again.
  69.                '#f))))))
  70.  
  71.  
  72. (define (mac-initialize-hook)
  73.   (mac-initialize-menubar)
  74.   (vanilla-initialize-hook))
  75.  
  76. (define (mac-compilation-error-hook)
  77.   ;; Nothing special needs to be done here.
  78.   '#f)
  79.  
  80.  
  81. ;;; Helper function to display messages in minibuffer.
  82.  
  83. (define (mac-status message)
  84.   (ccl:set-mini-buffer (ccl::current-listener) 
  85.                        (format '#f "Haskell: ~a" message)))
  86.  
  87.  
  88. ;;; Call this function to enable the mcl interface.
  89.  
  90. (define (use-mac-interface)
  91.   (setf *haskell-enter-debugger-hook* (function mac-enter-debugger-hook))
  92.   (setf *haskell-exit-debugger-hook* (function mac-exit-debugger-hook))
  93.   (setf *haskell-input-hook* (function mac-input-hook))
  94.   (setf *haskell-command-hook* (function mac-command-hook))
  95.   (setf *haskell-initialize-hook* (function mac-initialize-hook))
  96.   (setf *haskell-compilation-error-hook* (function mac-compilation-error-hook))
  97.   (mac-initialize-hook))
  98.  
  99.  
  100.  
  101. ;;;=========================================================================
  102. ;;; Menubar setup
  103. ;;;=========================================================================
  104.  
  105.  
  106. ;;; Install the haskell menubar.
  107.  
  108. (define (mac-initialize-menubar)
  109.   (when (not *mac-haskell-menubar*)
  110.     ;; Fix up the Apple menu.
  111.     (let ((apple-menu ccl:*apple-menu*))
  112.       (apply #'ccl:remove-menu-items apple-menu (ccl:menu-items apple-menu))
  113.       (apply #'ccl:add-menu-items
  114.              apple-menu
  115.              (list (mac-make-menu-item 
  116.                      "About Yale Haskell…" (function mac-about-haskell) '#f)
  117.                    (mac-make-empty-menu-item))))
  118.     (setf *mac-haskell-menubar*
  119.           (list
  120.             ;; Include the standard MCL file menu.
  121.            (mac-find-standard-menu "File")
  122.            ;; Include the standard MCL edit menu.
  123.            (mac-find-standard-menu "Edit")
  124.            ;; Make our own Haskell menu.
  125.            (mac-make-menu
  126.              "Haskell"
  127.              (mac-make-window-menu-item
  128.               "Eval Expression…" (function mac-eval-expression) '#f)
  129.              (mac-make-window-menu-item
  130.               "Run Dialogue…" (function mac-run-dialogue) '#f)
  131.              (mac-make-window-menu-item
  132.               "Type Check Expression…" (function mac-report-type) '#f)
  133.              (mac-make-empty-menu-item)
  134.              (mac-make-window-menu-item
  135.               "Load File…" (function mac-load-file) '#f)
  136.              (mac-make-window-menu-item
  137.               "Run File…" (function mac-run-file) '#f)
  138.              (mac-make-window-menu-item
  139.               "Compile File…" (function mac-compile-file) '#f)
  140.              (mac-make-empty-menu-item)
  141.              (mac-make-window-menu-item
  142.               "Scratch Pad" (function mac-switch-to-pad) '#f)
  143.              (mac-make-empty-menu-item)
  144.              (mac-make-menu-item
  145.               "Printers…" (function mac-set-printers) '#f)
  146.              (mac-make-menu-item
  147.               "Optimizers…" (function mac-set-optimizers) '#f)
  148.              (mac-make-empty-menu-item)
  149.              (mac-make-menu-item
  150.               "Tutorial" (function mac-run-tutorial) '#f)
  151.              (mac-make-empty-menu-item)
  152.              (mac-make-menu-item
  153.               "Abort" (function ccl::interactive-abort) '#\.))
  154.            ;; Include the standard MCL windows menu.
  155.            (mac-find-standard-menu "Windows"))))
  156.   (ccl:set-menubar *mac-haskell-menubar*))
  157.  
  158.  
  159. ;;; Helper functions for making menus and menu items
  160.  
  161. (define (mac-make-menu-item title action key)
  162.   (cl:make-instance 'ccl:menu-item 
  163.     :menu-item-title title
  164.     :menu-item-action action
  165.     :command-key key))
  166.  
  167. (define (mac-make-window-menu-item title action key)
  168.   (cl:make-instance 'ccl:window-menu-item 
  169.     :menu-item-title title
  170.     :menu-item-action action
  171.     :command-key key))
  172.  
  173. (define (mac-make-empty-menu-item)
  174.   (cl:make-instance 'ccl:menu-item
  175.     :menu-item-title "-"
  176.     :disabled '#t))
  177.  
  178. (define (mac-make-menu title . items)
  179.   (cl:make-instance 'ccl:menu
  180.     :menu-title title
  181.     :menu-items items))
  182.  
  183.  
  184. ;;; Helper function to find menus from the standard MCL menubar
  185.  
  186. (define (mac-find-standard-menu title)
  187.   (mac-find-standard-menu-aux title ccl:*default-menubar*))
  188.  
  189. (define (mac-find-standard-menu-aux title menus)
  190.   (cond ((null? menus)
  191.          (error "Couldn't find standard menu ~s." title))
  192.         ((equal? title (ccl:menu-title (car menus)))
  193.          (car menus))
  194.         (else
  195.          (mac-find-standard-menu-aux title (cdr menus)))))
  196.  
  197.  
  198.  
  199.  
  200. ;;;=========================================================================
  201. ;;; Menu item handlers
  202. ;;;=========================================================================
  203.  
  204.  
  205. ;;; About Yale Haskell
  206.  
  207. (define (mac-about-haskell)
  208.   (ccl:message-dialog 
  209.     (format '#f "Yale Haskell ~A~A~%~
  210.                  Copyright (c) 1991~%~
  211.                  Yale University CS Dept."
  212.       *haskell-compiler-version*
  213.       *haskell-compiler-update*)))
  214.  
  215.  
  216. ;;; Evaluate expression/Run dialogue
  217. ;;; *** Maybe we could do some fancier status messages here.
  218.  
  219. (cl:defmethod mac-eval-expression ((w ccl:fred-window))
  220.   (let ((exp  (ccl:get-string-from-user "Enter the expression to evaluate:")))
  221.     (mac-save-buffers w)
  222.     (ccl:eval-enqueue
  223.       `(mac-eval
  224.         ',exp
  225.         ',(ccl:window-title w)
  226.         ',(mac-current-extension w)
  227.         ',(mac-current-module w)
  228.         ',(mac-current-filename w)))))
  229.  
  230. (define (mac-eval exp extension-name extension module-name maybe-file)
  231.   (haskell-eval exp extension-name extension module-name maybe-file)
  232.   (setf *remembered-module* module-name)
  233.   (when maybe-file (setf *remembered-file* maybe-file)))
  234.  
  235.  
  236. (cl:defmethod mac-run-dialogue ((w ccl:fred-window))
  237.   (let ((exp  (ccl:get-string-from-user "Enter the dialogue to run:")))
  238.     (mac-save-buffers w)
  239.     (ccl:eval-enqueue
  240.       `(mac-run
  241.         ',exp
  242.         ',(ccl:window-title w)
  243.         ',(mac-current-extension w)
  244.         ',(mac-current-module w)
  245.         ',(mac-current-filename w)))))
  246.  
  247. (define (mac-run exp extension-name extension module-name maybe-file)
  248.   (haskell-run exp extension-name extension module-name maybe-file)
  249.   (setf *remembered-module* module-name)
  250.   (when maybe-file (setf *remembered-file* maybe-file)))
  251.  
  252.  
  253. (cl:defmethod mac-report-type ((w ccl:fred-window))
  254.   (let ((exp  (ccl:get-string-from-user "Enter the expression to type check:")))
  255.     (mac-save-buffers w)
  256.     (ccl:eval-enqueue
  257.       `(mac-report-type-aux
  258.         ',exp
  259.         ',(ccl:window-title w)
  260.         ',(mac-current-extension w)
  261.         ',(mac-current-module w)
  262.         ',(mac-current-filename w)))))
  263.  
  264. (define (mac-report-type-aux exp extension-name extension module-name maybe-file)
  265.   (haskell-report-type exp extension-name extension module-name maybe-file)
  266.   (setf *remembered-module* module-name)
  267.   (when maybe-file (setf *remembered-file* maybe-file)))
  268.  
  269.  
  270.  
  271. ;;; File-related commands
  272. ;;; *** Maybe we could do some fancier status messages here.
  273.  
  274. (cl:defmethod mac-load-file ((w ccl:fred-window))
  275.   (let ((fname  (or (mac-current-filename w)
  276.                     (mac-pathname->namestring 
  277.                      (ccl:choose-file-dialog
  278.                       :mac-file-type '("TEXT")
  279.                       :button-string "Load")))))
  280.    (mac-save-buffers w)
  281.    (ccl:eval-enqueue
  282.     `(compile/load ',fname))))
  283.  
  284. (cl:defmethod mac-run-file ((w ccl:fred-window))
  285.   (let ((fname  (or (mac-current-filename w)
  286.                     (mac-pathname->namestring 
  287.                      (ccl:choose-file-dialog
  288.                       :mac-file-type '("TEXT")
  289.                       :button-string "Run")))))
  290.    (mac-save-buffers w)
  291.    (ccl:eval-enqueue
  292.     `(compile/run ',fname '()))))
  293.  
  294. (cl:defmethod mac-compile-file ((w ccl:fred-window))
  295.   (let ((fname  (or (mac-current-filename w)
  296.                     (mac-pathname->namestring 
  297.                      (ccl:choose-file-dialog
  298.                       :mac-file-type '("TEXT")
  299.                       :button-string "Compile")))))
  300.    (mac-save-buffers w)
  301.    (ccl:eval-enqueue
  302.     `(compile/compile ',fname))))
  303.  
  304.  
  305. ;;; Pads
  306.  
  307. (cl:defclass mac-pad-window (ccl:fred-window) ())
  308.  
  309. (cl:defmethod ccl:window-needs-saving-p ((w mac-pad-window))
  310.   (declare (ignore w))
  311.   '#f)
  312.  
  313. (cl:defmethod mac-switch-to-pad ((w ccl:fred-window))
  314.   (ccl:window-select
  315.      (cond ((is-type? 'ccl:listener w)
  316.             (or (mac-lookup-pad '|Main| '#f)
  317.                 (mac-create-pad '|Main| '#f)))
  318.            ((mac-pad-window? w)
  319.             w)
  320.            (else
  321.             (let ((mname  (mac-current-module-aux w)))
  322.               (or (mac-lookup-pad mname w)
  323.                   (mac-create-pad mname w))))
  324.            )))
  325.  
  326.  
  327. ;;; Printers/optimizers
  328.  
  329. (define (mac-set-printers)
  330.   (setf *printers*
  331.         (mac-make-checkbox-dialog *all-printers* *printers*)))
  332.  
  333. (define (mac-set-optimizers)
  334.   (setf *compiled-code-optimizers*
  335.         (mac-make-checkbox-dialog
  336.       *all-optimizers* *compiled-code-optimizers*)))
  337.  
  338.  
  339. ;;;=========================================================================
  340. ;;; Tutorial 
  341. ;;;=========================================================================
  342.  
  343. (define *tutorial-window* '#f)
  344. (define *tutorial-buffer* '#f)
  345. (define *tutorial-buffer-size* '#f)
  346. (define *tutorial-buffer-page-start* '#f)
  347. (define *tutorial-buffer-page-end* '#f)
  348.  
  349. (define *tutorial-filename* "$HASKELL/progs/tutorial/mac-tutorial.lhs")
  350. (define *tutorial-window-filename* "$HASKELL/progs/tutorial/temp.lhs")
  351.  
  352. (cl:defclass mac-tutorial-window (ccl:fred-window) ())
  353.  
  354. (cl:defmethod ccl:window-needs-saving-p ((w mac-tutorial-window))
  355.   (declare (ignore w))
  356.   '#f)
  357.  
  358. (define (mac-run-tutorial)
  359.   (mac-initialize-tutorial)
  360.   (ccl:window-select *tutorial-window*))
  361.  
  362. (define (mac-initialize-tutorial)
  363.   (when (not *tutorial-buffer*)
  364.     ;; Load the tutorial from the file.
  365.     (setf *tutorial-buffer* (ccl:make-buffer))
  366.     (ccl:buffer-insert-file *tutorial-buffer*
  367.       (expand-filename *tutorial-filename*))
  368.     (setf *tutorial-buffer-size* (ccl:buffer-size *tutorial-buffer*)))
  369.   (when (or (not *tutorial-window*) (not (ccl:wptr *tutorial-window*)))
  370.     ;; Reset the master tutorial buffer to the first page.
  371.     (setf *tutorial-buffer-page-start* 0)
  372.     (setf *tutorial-buffer-page-end* (mac-next-tutorial-page 0))
  373.     ;; Create and initialize the Fred window that holds the current page
  374.     ;; of the tutorial
  375.     (setf *tutorial-window* 
  376.     (cl:make-instance 'mac-tutorial-window :window-show '#f))
  377.     (ccl:set-window-filename *tutorial-window* 
  378.       (expand-filename *tutorial-window-filename*))
  379.     (ccl:set-window-title *tutorial-window* "Haskell Tutorial")
  380.     (mac-display-tutorial-page)))
  381.  
  382. (define (mac-display-tutorial-page)
  383.   (let ((buffer  (ccl:fred-buffer *tutorial-window*)))
  384.     (ccl:buffer-delete buffer 0 (ccl:buffer-size buffer))
  385.     (ccl:buffer-insert 
  386.       buffer
  387.       (ccl:buffer-substring 
  388.         *tutorial-buffer* 
  389.         *tutorial-buffer-page-start*
  390.         *tutorial-buffer-page-end*))
  391.     (ccl:set-mark buffer 0)
  392.     (ccl:fred-update *tutorial-window*)))
  393.  
  394.  
  395. ;;; Pages in the tutorial are delimited by #\page characters
  396.  
  397. (define (mac-next-tutorial-page i)
  398.   (or (ccl:buffer-string-pos *tutorial-buffer* (string #\page) 
  399.                              :start i :end *tutorial-buffer-size*)
  400.       *tutorial-buffer-size*))
  401.  
  402. (define (mac-prev-tutorial-page i)
  403.   (let ((page  (ccl:buffer-string-pos *tutorial-buffer* (string #\page)
  404.                                       :start 0 :end i :from-end '#t)))
  405.     (if page (1+ page) 0)))
  406.  
  407.  
  408. (define (mac-goto-next-tutorial-page w)
  409.   (cond ((not (eq? w *tutorial-window*))
  410.          (ccl:ed-beep))
  411.         ((eqv? *tutorial-buffer-page-end* *tutorial-buffer-size*)
  412.          (ccl:ed-beep))
  413.         (else
  414.          (setf *tutorial-buffer-page-start* (1+ *tutorial-buffer-page-end*))
  415.          (setf *tutorial-buffer-page-end* 
  416.                (mac-next-tutorial-page *tutorial-buffer-page-start*))
  417.          (mac-display-tutorial-page))))
  418.  
  419. (define (mac-goto-prev-tutorial-page w)
  420.   (cond ((not (eq? w *tutorial-window*))
  421.          (ccl:ed-beep))
  422.         ((eqv? *tutorial-buffer-page-start* 0)
  423.          (ccl:ed-beep))
  424.         (else
  425.          (setf *tutorial-buffer-page-end* (1- *tutorial-buffer-page-start*))
  426.          (setf *tutorial-buffer-page-start*
  427.                (mac-prev-tutorial-page *tutorial-buffer-page-end*))
  428.          (mac-display-tutorial-page))))
  429.  
  430. (define (mac-refresh-tutorial-page w)
  431.   (cond ((not (eq? w *tutorial-window*))
  432.          (ccl:ed-beep))
  433.         (else
  434.          (mac-display-tutorial-page))))
  435.  
  436.  
  437.  
  438. ;;;=========================================================================
  439. ;;; Fred comtab setup
  440. ;;;=========================================================================
  441.  
  442. (define *mac-control-c-comtab* (ccl:make-comtab (function ccl:ed-beep)))
  443.  
  444. (ccl:comtab-set-key *mac-control-c-comtab* '(#\e) 
  445.   (function mac-eval-expression)
  446.   "Evaluate Haskell expression")
  447. (ccl:comtab-set-key *mac-control-c-comtab* '(#\r) 
  448.   (function mac-run-dialogue)
  449.   "Run Haskell dialogue")
  450. (ccl:comtab-set-key *mac-control-c-comtab* '(#\t) 
  451.   (function mac-report-type)
  452.   "Type check Haskell expression")
  453. (ccl:comtab-set-key *mac-control-c-comtab* '(#\l) 
  454.   (function mac-load-file)
  455.   "Load Haskell file")
  456. (ccl:comtab-set-key *mac-control-c-comtab* '(:control #\r) 
  457.   (function mac-run-file)
  458.   "Run Haskell file")
  459. (ccl:comtab-set-key *mac-control-c-comtab* '(#\c) 
  460.   (function mac-compile-file)
  461.   "Compile Haskell file")
  462. (ccl:comtab-set-key *mac-control-c-comtab* '(#\p) 
  463.   (function mac-switch-to-pad)
  464.   "Scratch pad")
  465. (ccl:comtab-set-key *mac-control-c-comtab* '(:control #\p) 
  466.   (lambda (w) (declare (ignore w)) (mac-set-printers))
  467.   "Haskell printers menu")
  468. (ccl:comtab-set-key *mac-control-c-comtab* '(:control #\o) 
  469.   (lambda (w) (declare (ignore w)) (mac-set-optimizers))
  470.   "Haskell optimizers menu")
  471. (ccl:comtab-set-key *mac-control-c-comtab* '(#\i) 
  472.   (lambda (w) (declare (ignore w)) (ccl::interactive-abort))
  473.   "Abort")
  474. (ccl:comtab-set-key *mac-control-c-comtab* '(:control #\f)
  475.   (function mac-goto-next-tutorial-page)
  476.   "Go forward to the next tutorial page.")
  477. (ccl:comtab-set-key *mac-control-c-comtab* '(:control #\b)
  478.   (function mac-goto-prev-tutorial-page)
  479.   "Go backward to the previous tutorial page.")
  480. (ccl:comtab-set-key *mac-control-c-comtab* '(:control #\l)
  481.   (function mac-refresh-tutorial-page)
  482.   "Restore the original text of this tutorial page.")
  483.  
  484.                     
  485.  
  486. (ccl:comtab-set-key ccl:*comtab* '(:control #\c) *mac-control-c-comtab*)
  487.  
  488.  
  489. ;;; Mess with the listener comtab to fix bug that prevents it from reading
  490. ;;; empty lines.  Basically, if user types return on empty line at end
  491. ;;; of buffer, bypass all the fancy listener crap and just treat it like
  492. ;;; a literal newline character.
  493.  
  494. (define (mac-hack-cr w)
  495.   (let* ((buffer  (ccl:fred-buffer w))
  496.          (size    (ccl:buffer-size buffer)))
  497.     (if (and (eqv? (ccl:buffer-position buffer)  size)
  498.              (eqv? (ccl:buffer-char buffer (- size 1)) #\newline))
  499.         (ccl::ed-self-insert w)
  500.         (ccl::ed-enter-command w))))
  501.   
  502.  
  503. (ccl:comtab-set-key ccl:*listener-comtab* #\CR
  504.    (function mac-hack-cr))
  505.  
  506.  
  507. ;;; This makes the default type for new files created with Fred be .hs 
  508. ;;; instead of .lisp:
  509.  
  510. (setf ccl:*.lisp-pathname* #p".hs")
  511.  
  512.  
  513. ;;; This makes the creator for newly created Fred files be Yale Haskell
  514. ;;; instead of Macintosh Common Lisp.  Actually, I think it's an MCL
  515. ;;; bug that it's got this hardwired in, so I feel justified in messing
  516. ;;; with defining a method on something I shouldn't to get this to 
  517. ;;; do the right thing.
  518.  
  519. (cl:defmethod ccl:window-save-as :around ((w ccl:fred-window))
  520.   (let* ((new?    (not (ccl:window-filename w)))
  521.          (result  (cl:call-next-method w)))
  522.     (when new?
  523.       (let ((name  (ccl:window-filename w)))
  524.         (when name
  525.           (ccl:set-mac-file-creator 
  526.             name mumble-implementation::*mac-file-creator*))))
  527.     result))
  528.  
  529.  
  530. ;;; This is called when the system is started up (see savesys.lisp).
  531. ;;; The usual load-init-files stuff is useless on the mac because the
  532. ;;; pathnames make no sense.  Load an init file from the same directory
  533. ;;; as the executable, and another from the directory you started Haskell
  534. ;;; up from.
  535. ;;; Also, reset *default-pathname-defaults* and *environment-alist* here.
  536.  
  537. (define (mac-load-init-files)
  538.   (let ((startup    (ccl::startup-directory))
  539.         (home       (ccl::home-directory)))
  540.     (if home
  541.         ;; was started by double-clicking on document
  542.         (let ((s-init     (cl:merge-pathnames "yhaskell.scm" startup))
  543.               (h-init     (cl:merge-pathnames "yhaskell.scm" home)))
  544.           (setf cl:*default-pathname-defaults* home)
  545.           (setf *environment-alist*
  546.                 (list (cons "HOME" (mac-directory->namestring home))
  547.                       (cons "HASKELL" (mac-directory->namestring startup))))
  548.       (ccl:set-choose-file-default-directory home)
  549.           (when (cl:probe-file s-init) (cl:load s-init))
  550.           (when (cl:probe-file h-init) (cl:load h-init)))
  551.         ;; was started by double-clicking on executable
  552.         (let ((s-init     (cl:merge-pathnames "yhaskell.scm" startup)))
  553.           (setf cl:*default-pathname-defaults* startup)
  554.           (setf *environment-alist*
  555.                 (list (cons "HOME" (mac-directory->namestring startup))
  556.                       (cons "HASKELL" (mac-directory->namestring startup))))
  557.       (ccl:set-choose-file-default-directory startup)
  558.           (when (cl:probe-file s-init) (cl:load s-init))))))
  559.  
  560.  
  561.  
  562. ;;;=========================================================================
  563. ;;; Printers/optimizers menus
  564. ;;;=========================================================================
  565.  
  566.  
  567. ;;; Here are some support functions.  This is set up so that the check
  568. ;;; boxes will get aligned in two columns, with the doit/cancel buttons
  569. ;;; appearing at the top of a third column.
  570.  
  571. (define (mac-make-checkbox text on-p)
  572.   (cl:make-instance 'ccl:check-box-dialog-item
  573.     :view-size #@(125 15)
  574.     :dialog-item-text text
  575.     :check-box-checked-p on-p))
  576.  
  577. (define (mac-make-button text action default-p)
  578.   (cl:make-instance 'ccl:button-dialog-item
  579.     :view-size #@(72 15)
  580.     :dialog-item-text text
  581.     :dialog-item-action action
  582.     :default-button default-p))
  583.  
  584. (define (mac-make-dialog items doit-fn)
  585.   (cl:make-instance 'ccl:dialog
  586.     :view-size (ccl:make-point 350 (* 25 (cl:ceiling (length items) 2)))
  587.     :window-type :double-edge-box
  588.     :close-box-p  '#f
  589.     :view-font '("Chicago" 12 :srcor :plain)
  590.     :view-subviews
  591.       (append items
  592.               (list (mac-make-button 
  593.                       "Do it"
  594.                       (lambda (b) 
  595.                         (ccl:return-from-modal-dialog (funcall doit-fn b)))
  596.                       '#t)
  597.                     (mac-make-button 
  598.                       "Cancel"
  599.                       (lambda (b)
  600.                         (declare (ignore b))
  601.                         (ccl:return-from-modal-dialog :cancel))
  602.                       '#f)))))
  603.  
  604.  
  605. ;;; Here's the function to actually make the menu.  It returns
  606. ;;; the list of things that the user has checked off.
  607.  
  608. (define (mac-make-checkbox-dialog all-items current-items)
  609.   (let* ((flags  (map (lambda (i)
  610.                         (mac-make-checkbox (symbol->string i)
  611.                                            (memq i current-items)))
  612.                       all-items))
  613.          (doit   (lambda (b)
  614.                    (declare (ignore b))
  615.                    (let ((new-items  '()))
  616.                      (for-each
  617.                        (lambda (m i)
  618.                          (when (ccl:check-box-checked-p m)
  619.                            (push i new-items)))
  620.                        flags
  621.                        all-items)
  622.                      new-items))))
  623.     (ccl:modal-dialog (mac-make-dialog flags doit))))
  624.  
  625.  
  626.  
  627.  
  628. ;;;=========================================================================
  629. ;;; Fred-related utilities
  630. ;;;=========================================================================
  631.  
  632. ;;; Save modified buffers that are associated with files.
  633.  
  634. (define *mac-ask-before-saving* '#t)
  635.  
  636. (define (mac-save-buffers current-window)
  637.   (dolist (w (ccl:windows :class 'ccl:fred-window))
  638.     (when (or (and (ccl:window-needs-saving-p w)
  639.                    (or (eq? w current-window)
  640.                        (not *mac-ask-before-saving*)
  641.                        (ccl:y-or-n-dialog
  642.                         (format '#f "Save buffer ~a?" (ccl:window-title w)))))
  643.               (is-type? 'mac-tutorial-window w))
  644.       (ccl:window-save w))))
  645.  
  646.  
  647. ;;; If w is a Haskell source buffer, return the contents of its associated pad.
  648. ;;; If w is a pad, return its contents.
  649. ;;; Otherwise return the contents of the last pad used.
  650.  
  651. (define *mac-last-pad* '#f)
  652.  
  653. (define (mac-current-extension w)
  654.   (let ((pad  (mac-current-pad w)))
  655.     (if pad
  656.         (let ((buffer  (ccl:fred-buffer w)))
  657.           (ccl:buffer-substring buffer 0 (ccl:buffer-size buffer)))
  658.         "")))
  659.  
  660. (define (mac-current-pad w)
  661.   (setf *mac-last-pad*
  662.         (cond ((is-type? 'ccl:listener w)
  663.                *mac-last-pad*)
  664.               ((mac-pad-window? w)
  665.                w)
  666.               (else
  667.                (mac-lookup-pad (mac-current-module-aux w) w))
  668.               )))
  669.  
  670.  
  671. ;;; If w is a Haskell source buffer, find the module definition that the
  672. ;;; cursor is in, and return its name.
  673. ;;; If w is a pad, return the module name.
  674. ;;; Otherwise return the last module name used.
  675. ;;; Note that module names are symbols, not strings!
  676.  
  677. (define *mac-last-module* '|Main|)
  678.  
  679. (define (mac-current-module w)
  680.   (setf *mac-last-module*
  681.         (cond ((is-type? 'ccl:listener w)
  682.                *mac-last-module*)
  683.               ((mac-pad-window? w)
  684.                (mac-pad-window-module-name w))
  685.               (else
  686.                (mac-current-module-aux w))
  687.               )))
  688.  
  689.  
  690.  
  691. ;;; Note, you must save new buffers with .lhs extensions before
  692. ;;; literate syntax is recognized here....
  693.  
  694. (define *module-search-string* "module ")
  695. (define *module-search-string-end* (1- (string-length *module-search-string*)))
  696.  
  697. (define (mac-current-module-aux w)
  698.   (let* ((buffer    (ccl:fred-buffer w))
  699.      (pos       (ccl:buffer-position buffer))
  700.      (literate? (and (ccl:window-filename w)
  701.              (equal? (cl:pathname-type (ccl:window-filename w))
  702.                  "lhs"))))
  703.     (or (mac-module-search-backward buffer pos literate?)
  704.     (mac-module-search-forward buffer pos literate?)
  705.     '|Main|)))
  706.  
  707. (define (mac-module-search-backward buffer pos literate?)
  708.   (let ((mstart  (ccl:buffer-string-pos buffer *module-search-string*
  709.                     :end pos :from-end '#t)))
  710.     (cond ((not mstart)
  711.        '#f)
  712.       ((mac-module-really-matches buffer mstart literate?)
  713.        (mac-module-extract buffer mstart))
  714.       ((eqv? mstart 0)
  715.        '#f)
  716.       (else
  717.        (mac-module-search-backward buffer (1- mstart) literate?)))))
  718.  
  719. (define (mac-module-search-forward buffer pos literate?)
  720.   (let ((mstart  (ccl:buffer-string-pos buffer *module-search-string*
  721.                     :start pos)))
  722.     (cond ((not mstart)
  723.        '#f)
  724.       ((mac-module-really-matches buffer mstart literate?)
  725.        (mac-module-extract buffer mstart))
  726.       (else
  727.        (mac-module-search-forward buffer (1+ mstart) literate?)))))
  728.  
  729. (define (mac-module-really-matches buffer mstart literate?)
  730.   (let ((beg  (ccl:buffer-line-start buffer mstart)))
  731.     (if literate?
  732.     (eqv? (ccl:buffer-char buffer beg) '#\>)
  733.     (eqv? beg mstart))))
  734.  
  735. (define (mac-module-extract buffer mstart)
  736.   (multiple-value-bind (start end)
  737.       (ccl:buffer-word-bounds 
  738.         buffer
  739.     (ccl:buffer-skip-fwd-wsp&comments 
  740.       buffer
  741.       (+ mstart *module-search-string-end*)
  742.       (ccl:buffer-size buffer)))
  743.     (string->symbol (ccl:buffer-substring buffer start end))))
  744.  
  745.  
  746. ;;; Look up a pad window.
  747.  
  748. (define *mac-pad-list* '())
  749.  
  750. (define (mac-lookup-pad module-name file-window)
  751.   (mac-lookup-pad-aux module-name file-window *mac-pad-list*))
  752.  
  753. (define (mac-lookup-pad-aux module-name file-window pad-list)
  754.   (cond ((null? pad-list)
  755.          '#f)
  756.         ((and (eq? module-name (car (car pad-list)))
  757.               (eq? file-window (cadr (car pad-list)))
  758.               ;; Make sure window has not been closed!
  759.               (ccl:wptr (caddr (car pad-list))))
  760.          (caddr (car pad-list)))
  761.         (else
  762.          (mac-lookup-pad-aux module-name file-window (cdr pad-list)))
  763.         ))
  764.  
  765.  
  766. ;;; Create a new pad window and enter it into the cache.
  767.  
  768. (define (mac-create-pad module-name file-window)
  769.   (let ((pad  (cl:make-instance 'mac-pad-window
  770.                 :window-title (format '#f "Pad for module ~a" module-name))))
  771.     (push (list module-name file-window pad) *mac-pad-list*)
  772.     pad))
  773.  
  774.  
  775. (define (mac-pad-window? w)
  776.   (mac-pad-window-aux w *mac-pad-list*))
  777.  
  778. (define (mac-pad-window-aux w pad-list)
  779.   (cond ((null? pad-list)
  780.          '#f)
  781.         ((eq? w (caddr (car pad-list)))
  782.          (car pad-list))
  783.         (else
  784.          (mac-pad-window-aux w (cdr pad-list)))))
  785.  
  786. (define (mac-pad-window-module-name w)
  787.   (car (mac-pad-window? w)))
  788.  
  789. (define (mac-pad-window-file-window w)
  790.   (cadr (mac-pad-window? w)))
  791.  
  792.  
  793. ;;; Return the (Unix-style) filename string.
  794. ;;; If in a Haskell source buffer, return the name of its compilation unit.
  795. ;;; If in a pad, return the name of its compilation unit.
  796. ;;; Otherwise, return #f.
  797.  
  798. (define (mac-current-filename w)
  799.   (cond ((is-type? 'ccl:listener w)
  800.          '#f)
  801.         ((mac-pad-window? w)
  802.          (let ((file-window  (mac-pad-window-file-window w)))
  803.            (if file-window
  804.              (mac-current-filename-aux file-window)
  805.              '#f)))
  806.         (else
  807.          (mac-current-filename-aux w))
  808.         ))
  809.  
  810.  
  811. (define (mac-current-filename-aux w)
  812.   (let* ((buffer  (ccl:fred-buffer w))
  813.          (ustart  (ccl:buffer-string-pos buffer "-- unit:" :start 0)))
  814.     (cond (ustart
  815.            ;; The current buffer contains a unit specification
  816.            (let* ((start (ccl:buffer-skip-fwd-wsp&comments 
  817.                           buffer (+ ustart 8) (ccl:buffer-size buffer)))
  818.                   (end   (ccl:buffer-char-pos buffer #\newline :start start)))
  819.              (ccl:buffer-substring buffer start end)))
  820.           ((ccl:window-filename w)
  821.            ;; The current buffer has a filename
  822.            (mac-pathname->namestring (ccl:window-filename w)))
  823.           (else
  824.            ;; This is a new buffer that hasn't been saved to a file yet.
  825.            ;; *** Maybe we should ask for a name to save it with???
  826.            '#f))))
  827.  
  828.  
  829. ;;; Mess with pathname conversion.
  830.  
  831. (define (mac-pathname->namestring p)
  832.   (cl:substitute #\/ #\: (cl:namestring p)))
  833.  
  834. (define (mac-directory->namestring p)
  835.   (let* ((name  (mac-pathname->namestring p))
  836.          (n     (string-length name)))
  837.     (substring name 0 (1- n))))   ; drop trailing /
  838.   
  839.